home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / perl5db.pl < prev    next >
Encoding:
Perl Script  |  1999-12-28  |  56.4 KB  |  1,893 lines
  1. package DB;
  2.  
  3.  
  4. $VERSION = 1.00;
  5. $header = "perl5db.pl version $VERSION";
  6.  
  7.  
  8.  
  9.  
  10.  
  11.  
  12.  
  13.  
  14.  
  15.  
  16.  
  17.  
  18. BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
  19. local($^W) = 0;            # Switch run-time warnings off during init.
  20. warn (            # Do not ;-)
  21.       $dumpvar::hashDepth,     
  22.       $dumpvar::arrayDepth,    
  23.       $dumpvar::dumpDBFiles,   
  24.       $dumpvar::dumpPackages,  
  25.       $dumpvar::quoteHighBit,  
  26.       $dumpvar::printUndef,    
  27.       $dumpvar::globPrint,     
  28.       $dumpvar::usageOnly,
  29.       @ARGS,
  30.       $Carp::CarpLevel,
  31.       $panic,
  32.       $second_time,
  33.      ) if 0;
  34.  
  35. @ini_INC = @INC;
  36.  
  37.  
  38. $trace = $signal = $single = 0;    # Uninitialized warning suppression
  39. $inhibit_exit = $option{PrintRet} = 1;
  40.  
  41. @options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages 
  42.           compactDump veryCompact quote HighBit undefPrint
  43.           globPrint PrintRet UsageOnly frame AutoTrace
  44.           TTY noTTY ReadLine NonStop LineInfo maxTraceLen
  45.           recallCommand ShellBang pager tkRunning ornaments
  46.           signalLevel warnLevel dieLevel inhibit_exit);
  47.  
  48. %optionVars    = (
  49.          hashDepth    => \$dumpvar::hashDepth,
  50.          arrayDepth    => \$dumpvar::arrayDepth,
  51.          DumpDBFiles    => \$dumpvar::dumpDBFiles,
  52.          DumpPackages    => \$dumpvar::dumpPackages,
  53.          HighBit    => \$dumpvar::quoteHighBit,
  54.          undefPrint    => \$dumpvar::printUndef,
  55.          globPrint    => \$dumpvar::globPrint,
  56.          UsageOnly    => \$dumpvar::usageOnly,     
  57.          frame          => \$frame,
  58.          AutoTrace      => \$trace,
  59.          inhibit_exit   => \$inhibit_exit,
  60.          maxTraceLen    => \$maxtrace,
  61. );
  62.  
  63. %optionAction  = (
  64.           compactDump    => \&dumpvar::compactDump,
  65.           veryCompact    => \&dumpvar::veryCompact,
  66.           quote        => \&dumpvar::quote,
  67.           TTY        => \&TTY,
  68.           noTTY        => \&noTTY,
  69.           ReadLine    => \&ReadLine,
  70.           NonStop    => \&NonStop,
  71.           LineInfo    => \&LineInfo,
  72.           recallCommand    => \&recallCommand,
  73.           ShellBang    => \&shellBang,
  74.           pager        => \&pager,
  75.           signalLevel    => \&signalLevel,
  76.           warnLevel    => \&warnLevel,
  77.           dieLevel    => \&dieLevel,
  78.           tkRunning    => \&tkRunning,
  79.           ornaments    => \&ornaments,
  80.          );
  81.  
  82. %optionRequire = (
  83.           compactDump    => 'dumpvar.pl',
  84.           veryCompact    => 'dumpvar.pl',
  85.           quote        => 'dumpvar.pl',
  86.          );
  87.  
  88. $rl = 1 unless defined $rl;
  89. $warnLevel = 1 unless defined $warnLevel;
  90. $dieLevel = 1 unless defined $dieLevel;
  91. $signalLevel = 1 unless defined $signalLevel;
  92. $pre = [] unless defined $pre;
  93. $post = [] unless defined $post;
  94. $pretype = [] unless defined $pretype;
  95. warnLevel($warnLevel);
  96. dieLevel($dieLevel);
  97. signalLevel($signalLevel);
  98. &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
  99. &recallCommand("!") unless defined $prc;
  100. &shellBang("!") unless defined $psh;
  101. $maxtrace = 400 unless defined $maxtrace;
  102.  
  103. if (-e "/dev/tty") {
  104.   $rcfile=".perldb";
  105. } else {
  106.   $rcfile="perldb.ini";
  107. }
  108.  
  109. if (-f $rcfile) {
  110.     do "./$rcfile";
  111. } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
  112.     do "$ENV{LOGDIR}/$rcfile";
  113. } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
  114.     do "$ENV{HOME}/$rcfile";
  115. }
  116.  
  117. if (defined $ENV{PERLDB_OPTS}) {
  118.   parse_options($ENV{PERLDB_OPTS});
  119. }
  120.  
  121. if (exists $ENV{PERLDB_RESTART}) {
  122.   delete $ENV{PERLDB_RESTART};
  123.   @hist = get_list('PERLDB_HIST');
  124.   %break_on_load = get_list("PERLDB_ON_LOAD");
  125.   %postponed = get_list("PERLDB_POSTPONE");
  126.   my @had_breakpoints= get_list("PERLDB_VISITED");
  127.   for (0 .. $#had_breakpoints) {
  128.     my %pf = get_list("PERLDB_FILE_$_");
  129.     $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
  130.   }
  131.   my %opt = get_list("PERLDB_OPT");
  132.   my ($opt,$val);
  133.   while (($opt,$val) = each %opt) {
  134.     $val =~ s/[\\\']/\\$1/g;
  135.     parse_options("$opt'$val'");
  136.   }
  137.   @INC = get_list("PERLDB_INC");
  138.   @ini_INC = @INC;
  139.   $pretype = [get_list("PERLDB_PRETYPE")];
  140.   $pre = [get_list("PERLDB_PRE")];
  141.   $post = [get_list("PERLDB_POST")];
  142.   @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
  143. }
  144.  
  145. if ($notty) {
  146.   $runnonstop = 1;
  147. } else {
  148.   $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
  149.   $rl = 0, shift(@main::ARGV) if $emacs;
  150.  
  151.  
  152.   if (-e "/dev/tty") {
  153.     $console = "/dev/tty";
  154.   } elsif (-e "con" or $^O eq 'MSWin32') {
  155.     $console = "con";
  156.   } else {
  157.     $console = "sys\$command";
  158.   }
  159.  
  160.   if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
  161.     $console = undef;
  162.   }
  163.  
  164.   if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
  165.     $console = undef;
  166.   }
  167.  
  168.   $console = $tty if defined $tty;
  169.  
  170.   if (defined $console) {
  171.     open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
  172.     open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
  173.       || open(OUT,">&STDOUT");    # so we don't dongle stdout
  174.   } else {
  175.     open(IN,"<&STDIN");
  176.     open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
  177.     $console = 'STDIN/OUT';
  178.   }
  179.   $IN = \*IN;
  180.  
  181.   $OUT = \*OUT;
  182.   select($OUT);
  183.   $| = 1;            # for DB::OUT
  184.   select(STDOUT);
  185.  
  186.   $LINEINFO = $OUT unless defined $LINEINFO;
  187.   $lineinfo = $console unless defined $lineinfo;
  188.  
  189.   $| = 1;            # for real STDOUT
  190.  
  191.   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  192.   unless ($runnonstop) {
  193.     print $OUT "\nLoading DB routines from $header\n";
  194.     print $OUT ("Emacs support ",
  195.         $emacs ? "enabled" : "available",
  196.         ".\n");
  197.     print $OUT "\nEnter h or `h h' for help.\n\n";
  198.   }
  199. }
  200.  
  201. @ARGS = @ARGV;
  202. for (@args) {
  203.     s/\'/\\\'/g;
  204.     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  205. }
  206.  
  207. if (defined &afterinit) {    # May be defined in $rcfile
  208.   &afterinit();
  209. }
  210.  
  211. $I_m_init = 1;
  212.  
  213.  
  214. sub DB {
  215.     if ($single and not $second_time++) {
  216.       if ($runnonstop) {    # Disable until signal
  217.     for ($i=0; $i <= $#stack; ) {
  218.         $stack[$i++] &= ~1;
  219.     }
  220.     $single = 0;
  221.       }
  222.     }
  223.     $runnonstop = 0 if $single or $signal; # Disable it if interactive.
  224.     &save;
  225.     ($package, $filename, $line) = caller;
  226.     $filename_ini = $filename;
  227.     $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
  228.       "package $package;";    # this won't let them modify, alas
  229.     local(*dbline) = $main::{'_<' . $filename};
  230.     $max = $#dbline;
  231.     if (($stop,$action) = split(/\0/,$dbline{$line})) {
  232.     if ($stop eq '1') {
  233.         $signal |= 1;
  234.     } elsif ($stop) {
  235.         $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
  236.         $dbline{$line} =~ s/;9($|\0)/$1/;
  237.     }
  238.     }
  239.     my $was_signal = $signal;
  240.     $signal = 0;
  241.     if ($single || $trace || $was_signal) {
  242.     $term || &setterm;
  243.     if ($emacs) {
  244.         $position = "\032\032$filename:$line:0\n";
  245.         print $LINEINFO $position;
  246.     } else {
  247.         $sub =~ s/\'/::/;
  248.         $prefix = $sub =~ /::/ ? "" : "${'package'}::";
  249.         $prefix .= "$sub($filename:";
  250.         $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
  251.         if (length($prefix) > 30) {
  252.             $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
  253.         $prefix = "";
  254.         $infix = ":\t";
  255.         } else {
  256.         $infix = "):\t";
  257.         $position = "$prefix$line$infix$dbline[$line]$after";
  258.         }
  259.         if ($frame) {
  260.         print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
  261.         } else {
  262.         print $LINEINFO $position;
  263.         }
  264.         for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
  265.         last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
  266.         last if $signal;
  267.         $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
  268.         $incr_pos = "$prefix$i$infix$dbline[$i]$after";
  269.         $position .= $incr_pos;
  270.         if ($frame) {
  271.             print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
  272.         } else {
  273.             print $LINEINFO $incr_pos;
  274.         }
  275.         }
  276.     }
  277.     }
  278.     $evalarg = $action, &eval if $action;
  279.     if ($single || $was_signal) {
  280.     local $level = $level + 1;
  281.     foreach $evalarg (@$pre) {
  282.       &eval;
  283.     }
  284.     print $OUT $#stack . " levels deep in subroutine calls!\n"
  285.       if $single & 4;
  286.     $start = $line;
  287.     $incr = -1;        # for backward motion.
  288.     @typeahead = @$pretype, @typeahead;
  289.       CMD:
  290.     while (($term || &setterm),
  291.            ($term_pid == $$ or &resetterm),
  292.            defined ($cmd=&readline("  DB" . ('<' x $level) .
  293.                        ($#hist+1) . ('>' x $level) .
  294.                        " "))) {
  295.         $single = 0;
  296.         $signal = 0;
  297.         $cmd =~ s/\\$/\n/ && do {
  298.             $cmd .= &readline("  cont: ");
  299.             redo CMD;
  300.         };
  301.         $cmd =~ /^$/ && ($cmd = $laststep);
  302.         push(@hist,$cmd) if length($cmd) > 1;
  303.           PIPE: {
  304.             ($i) = split(/\s+/,$cmd);
  305.             eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
  306.             $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
  307.             $cmd =~ /^h$/ && do {
  308.             print $OUT $help;
  309.             next CMD; };
  310.             $cmd =~ /^h\s+h$/ && do {
  311.             print $OUT $summary;
  312.             next CMD; };
  313.             $cmd =~ /^h\s+(\S)$/ && do {
  314.             my $asked = "\Q$1";
  315.             if ($help =~ /^$asked/m) {
  316.               while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
  317.                 print $OUT $1;
  318.               }
  319.             } else {
  320.                 print $OUT "`$asked' is not a debugger command.\n";
  321.             }
  322.             next CMD; };
  323.             $cmd =~ /^t$/ && do {
  324.             $trace = !$trace;
  325.             print $OUT "Trace = ".($trace?"on":"off")."\n";
  326.             next CMD; };
  327.             $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
  328.             $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
  329.             foreach $subname (sort(keys %sub)) {
  330.                 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
  331.                 print $OUT $subname,"\n";
  332.                 }
  333.             }
  334.             next CMD; };
  335.             $cmd =~ /^v$/ && do {
  336.             list_versions(); next CMD};
  337.             $cmd =~ s/^X\b/V $package/;
  338.             $cmd =~ /^V$/ && do {
  339.             $cmd = "V $package"; };
  340.             $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
  341.             local ($savout) = select($OUT);
  342.             $packname = $1;
  343.             @vars = split(' ',$2);
  344.             do 'dumpvar.pl' unless defined &main::dumpvar;
  345.             if (defined &main::dumpvar) {
  346.                 local $frame = 0;
  347.                 local $doret = -2;
  348.                 &main::dumpvar($packname,@vars);
  349.             } else {
  350.                 print $OUT "dumpvar.pl not available.\n";
  351.             }
  352.             select ($savout);
  353.             next CMD; };
  354.             $cmd =~ s/^x\b/ / && do { # So that will be evaled
  355.             $onetimeDump = 'dump'; };
  356.             $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
  357.             methods($1); next CMD};
  358.             $cmd =~ s/^m\b/ / && do { # So this will be evaled
  359.             $onetimeDump = 'methods'; };
  360.             $cmd =~ /^f\b\s*(.*)/ && do {
  361.             $file = $1;
  362.             $file =~ s/\s+$//;
  363.             if (!$file) {
  364.                 print $OUT "The old f command is now the r command.\n";
  365.                 print $OUT "The new f command switches filenames.\n";
  366.                 next CMD;
  367.             }
  368.             if (!defined $main::{'_<' . $file}) {
  369.                 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
  370.                           $try = substr($try,2);
  371.                           print $OUT "Choosing $try matching `$file':\n";
  372.                           $file = $try;
  373.                       }}
  374.             }
  375.             if (!defined $main::{'_<' . $file}) {
  376.                 print $OUT "No file matching `$file' is loaded.\n";
  377.                 next CMD;
  378.             } elsif ($file ne $filename) {
  379.                 *dbline = $main::{'_<' . $file};
  380.                 $max = $#dbline;
  381.                 $filename = $file;
  382.                 $start = 1;
  383.                 $cmd = "l";
  384.               } else {
  385.                 print $OUT "Already in $file.\n";
  386.                 next CMD;
  387.               }
  388.               };
  389.             $cmd =~ s/^l\s+-\s*$/-/;
  390.             $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
  391.             $subname = $1;
  392.             $subname =~ s/\'/::/;
  393.             $subname = $package."::".$subname 
  394.               unless $subname =~ /::/;
  395.             $subname = "main".$subname if substr($subname,0,2) eq "::";
  396.             @pieces = split(/:/,find_sub($subname));
  397.             $subrange = pop @pieces;
  398.             $file = join(':', @pieces);
  399.             if ($file ne $filename) {
  400.                 *dbline = $main::{'_<' . $file};
  401.                 $max = $#dbline;
  402.                 $filename = $file;
  403.             }
  404.             if ($subrange) {
  405.                 if (eval($subrange) < -$window) {
  406.                 $subrange =~ s/-.*/+/;
  407.                 }
  408.                 $cmd = "l $subrange";
  409.             } else {
  410.                 print $OUT "Subroutine $subname not found.\n";
  411.                 next CMD;
  412.             } };
  413.             $cmd =~ /^\.$/ && do {
  414.             $incr = -1;        # for backward motion.
  415.             $start = $line;
  416.             $filename = $filename_ini;
  417.             *dbline = $main::{'_<' . $filename};
  418.             $max = $#dbline;
  419.             print $LINEINFO $position;
  420.             next CMD };
  421.             $cmd =~ /^w\b\s*(\d*)$/ && do {
  422.             $incr = $window - 1;
  423.             $start = $1 if $1;
  424.             $start -= $preview;
  425.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  426.             $cmd =~ /^-$/ && do {
  427.             $start -= $incr + $window + 1;
  428.             $start = 1 if $start <= 0;
  429.             $incr = $window - 1;
  430.             $cmd = 'l ' . ($start) . '+'; };
  431.             $cmd =~ /^l$/ && do {
  432.             $incr = $window - 1;
  433.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  434.             $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
  435.             $start = $1 if $1;
  436.             $incr = $2;
  437.             $incr = $window - 1 unless $incr;
  438.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  439.             $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
  440.             $end = (!defined $2) ? $max : ($4 ? $4 : $2);
  441.             $end = $max if $end > $max;
  442.             $i = $2;
  443.             $i = $line if $i eq '.';
  444.             $i = 1 if $i < 1;
  445.             $incr = $end - $i;
  446.             if ($emacs) {
  447.                 print $OUT "\032\032$filename:$i:0\n";
  448.                 $i = $end;
  449.             } else {
  450.                 for (; $i <= $end; $i++) {
  451.                     ($stop,$action) = split(/\0/, $dbline{$i});
  452.                     $arrow = ($i==$line 
  453.                       and $filename eq $filename_ini) 
  454.                   ?  '==>' 
  455.                     : ($dbline[$i]+0 ? ':' : ' ') ;
  456.                 $arrow .= 'b' if $stop;
  457.                 $arrow .= 'a' if $action;
  458.                 print $OUT "$i$arrow\t", $dbline[$i];
  459.                 last if $signal;
  460.                 }
  461.             }
  462.             $start = $i; # remember in case they want more
  463.             $start = $max if $start > $max;
  464.             next CMD; };
  465.             $cmd =~ /^D$/ && do {
  466.               print $OUT "Deleting all breakpoints...\n";
  467.               my $file;
  468.               for $file (keys %had_breakpoints) {
  469.             local *dbline = $main::{'_<' . $file};
  470.             my $max = $#dbline;
  471.             my $was;
  472.             
  473.             for ($i = 1; $i <= $max ; $i++) {
  474.                 if (defined $dbline{$i}) {
  475.                 $dbline{$i} =~ s/^[^\0]+//;
  476.                 if ($dbline{$i} =~ s/^\0?$//) {
  477.                     delete $dbline{$i};
  478.                 }
  479.                 }
  480.             }
  481.               }
  482.               undef %postponed;
  483.               undef %postponed_file;
  484.               undef %break_on_load;
  485.               undef %had_breakpoints;
  486.               next CMD; };
  487.             $cmd =~ /^L$/ && do {
  488.               my $file;
  489.               for $file (keys %had_breakpoints) {
  490.             local *dbline = $main::{'_<' . $file};
  491.             my $max = $#dbline;
  492.             my $was;
  493.             
  494.             for ($i = 1; $i <= $max; $i++) {
  495.                 if (defined $dbline{$i}) {
  496.                     print "$file:\n" unless $was++;
  497.                 print $OUT " $i:\t", $dbline[$i];
  498.                 ($stop,$action) = split(/\0/, $dbline{$i});
  499.                 print $OUT "   break if (", $stop, ")\n"
  500.                   if $stop;
  501.                 print $OUT "   action:  ", $action, "\n"
  502.                   if $action;
  503.                 last if $signal;
  504.                 }
  505.             }
  506.               }
  507.               if (%postponed) {
  508.             print $OUT "Postponed breakpoints in subroutines:\n";
  509.             my $subname;
  510.             for $subname (keys %postponed) {
  511.               print $OUT " $subname\t$postponed{$subname}\n";
  512.               last if $signal;
  513.             }
  514.               }
  515.               my @have = map { # Combined keys
  516.             keys %{$postponed_file{$_}}
  517.               } keys %postponed_file;
  518.               if (@have) {
  519.             print $OUT "Postponed breakpoints in files:\n";
  520.             my ($file, $line);
  521.             for $file (keys %postponed_file) {
  522.               my $db = $postponed_file{$file};
  523.               print $OUT " $file:\n";
  524.               for $line (sort {$a <=> $b} keys %$db) {
  525.                 print $OUT "  $line:\n";
  526.                 my ($stop,$action) = split(/\0/, $$db{$line});
  527.                 print $OUT "    break if (", $stop, ")\n"
  528.                   if $stop;
  529.                 print $OUT "    action:  ", $action, "\n"
  530.                   if $action;
  531.                 last if $signal;
  532.               }
  533.               last if $signal;
  534.             }
  535.               }
  536.               if (%break_on_load) {
  537.             print $OUT "Breakpoints on load:\n";
  538.             my $file;
  539.             for $file (keys %break_on_load) {
  540.               print $OUT " $file\n";
  541.               last if $signal;
  542.             }
  543.               }
  544.               next CMD; };
  545.             $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
  546.             my $file = $1; $file =~ s/\s+$//;
  547.             {
  548.               $break_on_load{$file} = 1;
  549.               $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
  550.               $file .= '.pm', redo unless $file =~ /\./;
  551.             }
  552.             $had_breakpoints{$file} = 1;
  553.             print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
  554.             next CMD; };
  555.             $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
  556.             my $cond = $3 || '1';
  557.             my ($subname, $break) = ($2, $1 eq 'postpone');
  558.             $subname =~ s/\'/::/;
  559.             $subname = "${'package'}::" . $subname
  560.               unless $subname =~ /::/;
  561.             $subname = "main".$subname if substr($subname,0,2) eq "::";
  562.             $postponed{$subname} = $break 
  563.               ? "break +0 if $cond" : "compile";
  564.             next CMD; };
  565.             $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
  566.             $subname = $1;
  567.             $cond = $2 || '1';
  568.             $subname =~ s/\'/::/;
  569.             $subname = "${'package'}::" . $subname
  570.               unless $subname =~ /::/;
  571.             $subname = "main".$subname if substr($subname,0,2) eq "::";
  572.             ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
  573.             $i += 0;
  574.             if ($i) {
  575.                 $filename = $file;
  576.                 *dbline = $main::{'_<' . $filename};
  577.                 $had_breakpoints{$filename} = 1;
  578.                 $max = $#dbline;
  579.                 ++$i while $dbline[$i] == 0 && $i < $max;
  580.                 $dbline{$i} =~ s/^[^\0]*/$cond/;
  581.             } else {
  582.                 print $OUT "Subroutine $subname not found.\n";
  583.             }
  584.             next CMD; };
  585.             $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
  586.             $i = ($1?$1:$line);
  587.             $cond = $2 || '1';
  588.             if ($dbline[$i] == 0) {
  589.                 print $OUT "Line $i not breakable.\n";
  590.             } else {
  591.                 $had_breakpoints{$filename} = 1;
  592.                 $dbline{$i} =~ s/^[^\0]*/$cond/;
  593.             }
  594.             next CMD; };
  595.             $cmd =~ /^d\b\s*(\d+)?/ && do {
  596.             $i = ($1?$1:$line);
  597.             $dbline{$i} =~ s/^[^\0]*//;
  598.             delete $dbline{$i} if $dbline{$i} eq '';
  599.             next CMD; };
  600.             $cmd =~ /^A$/ && do {
  601.               my $file;
  602.               for $file (keys %had_breakpoints) {
  603.             local *dbline = $main::{'_<' . $file};
  604.             my $max = $#dbline;
  605.             my $was;
  606.             
  607.             for ($i = 1; $i <= $max ; $i++) {
  608.                 if (defined $dbline{$i}) {
  609.                 $dbline{$i} =~ s/\0[^\0]*//;
  610.                 delete $dbline{$i} if $dbline{$i} eq '';
  611.                 }
  612.             }
  613.               }
  614.               next CMD; };
  615.             $cmd =~ /^O\s*$/ && do {
  616.             for (@options) {
  617.                 &dump_option($_);
  618.             }
  619.             next CMD; };
  620.             $cmd =~ /^O\s*(\S.*)/ && do {
  621.             parse_options($1);
  622.             next CMD; };
  623.             $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
  624.             push @$pre, action($1);
  625.             next CMD; };
  626.             $cmd =~ /^>>\s*(.*)/ && do {
  627.             push @$post, action($1);
  628.             next CMD; };
  629.             $cmd =~ /^<\s*(.*)/ && do {
  630.                 $pre = [], next CMD unless $1;
  631.             $pre = [action($1)];
  632.             next CMD; };
  633.             $cmd =~ /^>\s*(.*)/ && do {
  634.                 $post = [], next CMD unless $1;
  635.             $post = [action($1)];
  636.             next CMD; };
  637.             $cmd =~ /^\{\{\s*(.*)/ && do {
  638.             push @$pretype, $1;
  639.             next CMD; };
  640.             $cmd =~ /^\{\s*(.*)/ && do {
  641.                 $pretype = [], next CMD unless $1;
  642.             $pretype = [$1];
  643.             next CMD; };
  644.             $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
  645.             $i = $1; $j = $3;
  646.             if ($dbline[$i] == 0) {
  647.                 print $OUT "Line $i may not have an action.\n";
  648.             } else {
  649.                 $dbline{$i} =~ s/\0[^\0]*//;
  650.                 $dbline{$i} .= "\0" . action($j);
  651.             }
  652.             next CMD; };
  653.             $cmd =~ /^n$/ && do {
  654.                 end_report(), next CMD if $finished and $level <= 1;
  655.             $single = 2;
  656.             $laststep = $cmd;
  657.             last CMD; };
  658.             $cmd =~ /^s$/ && do {
  659.                 end_report(), next CMD if $finished and $level <= 1;
  660.             $single = 1;
  661.             $laststep = $cmd;
  662.             last CMD; };
  663.             $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
  664.                 end_report(), next CMD if $finished and $level <= 1;
  665.             $i = $1;
  666.             if ($i =~ /\D/) { # subroutine name
  667.                 ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/);
  668.                 $i += 0;
  669.                 if ($i) {
  670.                     $filename = $file;
  671.                 *dbline = $main::{'_<' . $filename};
  672.                 $had_breakpoints{$filename}++;
  673.                 $max = $#dbline;
  674.                 ++$i while $dbline[$i] == 0 && $i < $max;
  675.                 } else {
  676.                 print $OUT "Subroutine $subname not found.\n";
  677.                 next CMD; 
  678.                 }
  679.             }
  680.             if ($i) {
  681.                 if ($dbline[$i] == 0) {
  682.                 print $OUT "Line $i not breakable.\n";
  683.                 next CMD;
  684.                 }
  685.                 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
  686.             }
  687.             for ($i=0; $i <= $#stack; ) {
  688.                 $stack[$i++] &= ~1;
  689.             }
  690.             last CMD; };
  691.             $cmd =~ /^r$/ && do {
  692.                 end_report(), next CMD if $finished and $level <= 1;
  693.             $stack[$#stack] |= 1;
  694.             $doret = $option{PrintRet} ? $#stack - 1 : -2;
  695.             last CMD; };
  696.             $cmd =~ /^R$/ && do {
  697.                 print $OUT "Warning: some settings and command-line options may be lost!\n";
  698.             my (@script, @flags, $cl);
  699.             push @flags, '-w' if $ini_warn;
  700.             for (@ini_INC) {
  701.               push @flags, '-I', $_;
  702.             }
  703.             set_list("PERLDB_INC", @ini_INC);
  704.             if ($0 eq '-e') {
  705.               for (1..$#{'::_<-e'}) { # The first line is PERL5DB
  706.                 chomp ($cl =  $ {'::_<-e'}[$_]);
  707.                 push @script, '-e', $cl;
  708.               }
  709.             } else {
  710.               @script = $0;
  711.             }
  712.             set_list("PERLDB_HIST", 
  713.                  $term->Features->{getHistory} 
  714.                  ? $term->GetHistory : @hist);
  715.             my @had_breakpoints = keys %had_breakpoints;
  716.             set_list("PERLDB_VISITED", @had_breakpoints);
  717.             set_list("PERLDB_OPT", %option);
  718.             set_list("PERLDB_ON_LOAD", %break_on_load);
  719.             my @hard;
  720.             for (0 .. $#had_breakpoints) {
  721.               my $file = $had_breakpoints[$_];
  722.               *dbline = $main::{'_<' . $file};
  723.               next unless %dbline or $postponed_file{$file};
  724.               (push @hard, $file), next 
  725.                 if $file =~ /^\(eval \d+\)$/;
  726.               my @add;
  727.               @add = %{$postponed_file{$file}}
  728.                 if $postponed_file{$file};
  729.               set_list("PERLDB_FILE_$_", %dbline, @add);
  730.             }
  731.             for (@hard) { # Yes, really-really...
  732.               *dbline = $main::{'_<' . $_};
  733.               my ($quoted, $sub, %subs, $line) = quotemeta $_;
  734.               for $sub (keys %sub) {
  735.                 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
  736.                 $subs{$sub} = [$1, $2];
  737.               }
  738.               unless (%subs) {
  739.                 print $OUT
  740.                   "No subroutines in $_, ignoring breakpoints.\n";
  741.                 next;
  742.               }
  743.             LINES: for $line (keys %dbline) {
  744.                 my ($offset, $sub, $found);
  745.               SUBS: for $sub (keys %subs) {
  746.                   if ($subs{$sub}->[1] >= $line # Not after the subroutine
  747.                   and (not defined $offset # Not caught
  748.                        or $offset < 0 )) { # or badly caught
  749.                 $found = $sub;
  750.                 $offset = $line - $subs{$sub}->[0];
  751.                 $offset = "+$offset", last SUBS if $offset >= 0;
  752.                   }
  753.                 }
  754.                 if (defined $offset) {
  755.                   $postponed{$found} =
  756.                 "break $offset if $dbline{$line}";
  757.                 } else {
  758.                   print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
  759.                 }
  760.               }
  761.             }
  762.             set_list("PERLDB_POSTPONE", %postponed);
  763.             set_list("PERLDB_PRETYPE", @$pretype);
  764.             set_list("PERLDB_PRE", @$pre);
  765.             set_list("PERLDB_POST", @$post);
  766.             set_list("PERLDB_TYPEAHEAD", @typeahead);
  767.             $ENV{PERLDB_RESTART} = 1;
  768.             exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
  769.             print $OUT "exec failed: $!\n";
  770.             last CMD; };
  771.             $cmd =~ /^T$/ && do {
  772.             print_trace($OUT, 1); # skip DB
  773.             next CMD; };
  774.             $cmd =~ /^\/(.*)$/ && do {
  775.             $inpat = $1;
  776.             $inpat =~ s:([^\\])/$:$1:;
  777.             if ($inpat ne "") {
  778.                 eval '$inpat =~ m'."\a$inpat\a";    
  779.                 if ($@ ne "") {
  780.                 print $OUT "$@";
  781.                 next CMD;
  782.                 }
  783.                 $pat = $inpat;
  784.             }
  785.             $end = $start;
  786.             $incr = -1;
  787.             eval '
  788.                 for (;;) {
  789.                 ++$start;
  790.                 $start = 1 if ($start > $max);
  791.                 last if ($start == $end);
  792.                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
  793.                     if ($emacs) {
  794.                     print $OUT "\032\032$filename:$start:0\n";
  795.                     } else {
  796.                     print $OUT "$start:\t", $dbline[$start], "\n";
  797.                     }
  798.                     last;
  799.                 }
  800.                 } ';
  801.             print $OUT "/$pat/: not found\n" if ($start == $end);
  802.             next CMD; };
  803.             $cmd =~ /^\?(.*)$/ && do {
  804.             $inpat = $1;
  805.             $inpat =~ s:([^\\])\?$:$1:;
  806.             if ($inpat ne "") {
  807.                 eval '$inpat =~ m'."\a$inpat\a";    
  808.                 if ($@ ne "") {
  809.                 print $OUT "$@";
  810.                 next CMD;
  811.                 }
  812.                 $pat = $inpat;
  813.             }
  814.             $end = $start;
  815.             $incr = -1;
  816.             eval '
  817.                 for (;;) {
  818.                 --$start;
  819.                 $start = $max if ($start <= 0);
  820.                 last if ($start == $end);
  821.                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
  822.                     if ($emacs) {
  823.                     print $OUT "\032\032$filename:$start:0\n";
  824.                     } else {
  825.                     print $OUT "$start:\t", $dbline[$start], "\n";
  826.                     }
  827.                     last;
  828.                 }
  829.                 } ';
  830.             print $OUT "?$pat?: not found\n" if ($start == $end);
  831.             next CMD; };
  832.             $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
  833.             pop(@hist) if length($cmd) > 1;
  834.             $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
  835.             $cmd = $hist[$i] . "\n";
  836.             print $OUT $cmd;
  837.             redo CMD; };
  838.             $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
  839.             &system($1);
  840.             next CMD; };
  841.             $cmd =~ /^$rc([^$rc].*)$/ && do {
  842.             $pat = "^$1";
  843.             pop(@hist) if length($cmd) > 1;
  844.             for ($i = $#hist; $i; --$i) {
  845.                 last if $hist[$i] =~ /$pat/;
  846.             }
  847.             if (!$i) {
  848.                 print $OUT "No such command!\n\n";
  849.                 next CMD;
  850.             }
  851.             $cmd = $hist[$i] . "\n";
  852.             print $OUT $cmd;
  853.             redo CMD; };
  854.             $cmd =~ /^$sh$/ && do {
  855.             &system($ENV{SHELL}||"/bin/sh");
  856.             next CMD; };
  857.             $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
  858.             &system($ENV{SHELL}||"/bin/sh","-c",$1);
  859.             next CMD; };
  860.             $cmd =~ /^H\b\s*(-(\d+))?/ && do {
  861.             $end = $2?($#hist-$2):0;
  862.             $hist = 0 if $hist < 0;
  863.             for ($i=$#hist; $i>$end; $i--) {
  864.                 print $OUT "$i: ",$hist[$i],"\n"
  865.                   unless $hist[$i] =~ /^.?$/;
  866.             };
  867.             next CMD; };
  868.             $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
  869.             $cmd =~ s/^p\b/print {\$DB::OUT} /;
  870.             $cmd =~ /^=/ && do {
  871.             if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
  872.                 $alias{$k}="s~$k~$v~";
  873.                 print $OUT "$k = $v\n";
  874.             } elsif ($cmd =~ /^=\s*$/) {
  875.                 foreach $k (sort keys(%alias)) {
  876.                 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
  877.                     print $OUT "$k = $v\n";
  878.                 } else {
  879.                     print $OUT "$k\t$alias{$k}\n";
  880.                 };
  881.                 };
  882.             };
  883.             next CMD; };
  884.             $cmd =~ /^\|\|?\s*[^|]/ && do {
  885.             if ($pager =~ /^\|/) {
  886.                 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
  887.                 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
  888.             } else {
  889.                 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
  890.             }
  891.             unless ($piped=open(OUT,$pager)) {
  892.                 &warn("Can't pipe output to `$pager'");
  893.                 if ($pager =~ /^\|/) {
  894.                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
  895.                 open(STDOUT,">&SAVEOUT")
  896.                   || &warn("Can't restore STDOUT");
  897.                 close(SAVEOUT);
  898.                 } else {
  899.                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
  900.                 }
  901.                 next CMD;
  902.             }
  903.             $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
  904.               && "" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE};
  905.             $selected= select(OUT);
  906.             $|= 1;
  907.             select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
  908.             $cmd =~ s/^\|+\s*//;
  909.             redo PIPE; };
  910.             $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
  911.             $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
  912.             $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
  913.         }        # PIPE:
  914.         $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
  915.         if ($onetimeDump) {
  916.         $onetimeDump = undef;
  917.         } elsif ($term_pid == $$) {
  918.         print $OUT "\n";
  919.         }
  920.     } continue {        # CMD:
  921.         if ($piped) {
  922.         if ($pager =~ /^\|/) {
  923.             $?= 0;  close(OUT) || &warn("Can't close DB::OUT");
  924.             &warn( "Pager `$pager' failed: ",
  925.               ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
  926.               ( $? & 128 ) ? " (core dumped)" : "",
  927.               ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
  928.             open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
  929.             open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
  930.             $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
  931.         } else {
  932.             open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
  933.         }
  934.         close(SAVEOUT);
  935.         select($selected), $selected= "" unless $selected eq "";
  936.         $piped= "";
  937.         }
  938.     }            # CMD:
  939.     $exiting = 1 unless defined $cmd;
  940.     foreach $evalarg (@$post) {
  941.       &eval;
  942.     }
  943.     }                # if ($single || $signal)
  944.     ($@, $!, $,, $/, $\, $^W) = @saved;
  945.     ();
  946. }
  947.  
  948.  
  949. sub sub {
  950.     my ($al, $ret, @ret) = "";
  951.     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
  952.     $al = " for $$sub";
  953.     }
  954.     push(@stack, $single);
  955.     $single &= 1;
  956.     $single |= 4 if $#stack == $deep;
  957.     ($frame & 4 
  958.      ? ( (print $LINEINFO ' ' x ($#stack - 1), "in  "), 
  959.      print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  960.      : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
  961.     if (wantarray) {
  962.     @ret = &$sub;
  963.     $single |= pop(@stack);
  964.     ($frame & 4 
  965.      ? ( (print $LINEINFO ' ' x $#stack, "out "), 
  966.          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  967.      : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
  968.     print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
  969.             "list context return from $sub:\n"), dumpit( \@ret ),
  970.       $doret = -2 if $doret eq $#stack or $frame & 16;
  971.     @ret;
  972.     } else {
  973.     $ret = &$sub;
  974.     $single |= pop(@stack);
  975.     ($frame & 4 
  976.      ? ( (print $LINEINFO ' ' x $#stack, "out "), 
  977.           print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  978.      : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
  979.     print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
  980.             "scalar context return from $sub: "), dumpit( $ret ),
  981.       $doret = -2 if $doret eq $#stack or $frame & 16;
  982.     $ret;
  983.     }
  984. }
  985.  
  986. sub save {
  987.     @saved = ($@, $!, $,, $/, $\, $^W);
  988.     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
  989. }
  990.  
  991.  
  992. sub eval {
  993.     my @res;
  994.     {
  995.     local (@stack) = @stack; # guard against recursive debugging
  996.     my $otrace = $trace;
  997.     my $osingle = $single;
  998.     my $od = $^D;
  999.     @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
  1000.     $trace = $otrace;
  1001.     $single = $osingle;
  1002.     $^D = $od;
  1003.     }
  1004.     my $at = $@;
  1005.     local $saved[0];        # Preserve the old value of $@
  1006.     eval "&DB::save";
  1007.     if ($at) {
  1008.     print $OUT $at;
  1009.     } elsif ($onetimeDump eq 'dump') {
  1010.     dumpit(\@res);
  1011.     } elsif ($onetimeDump eq 'methods') {
  1012.     methods($res[0]);
  1013.     }
  1014. }
  1015.  
  1016. sub postponed_sub {
  1017.   my $subname = shift;
  1018.   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
  1019.     my $offset = $1 || 0;
  1020.     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
  1021.     $i += $offset;
  1022.     if ($i) {
  1023.       local *dbline = $main::{'_<' . $file};
  1024.       local $^W = 0;        # != 0 is magical below
  1025.       $had_breakpoints{$file}++;
  1026.       my $max = $#dbline;
  1027.       ++$i until $dbline[$i] != 0 or $i >= $max;
  1028.       $dbline{$i} = delete $postponed{$subname};
  1029.     } else {
  1030.       print $OUT "Subroutine $subname not found.\n";
  1031.     }
  1032.     return;
  1033.   }
  1034.   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
  1035. }
  1036.  
  1037. sub postponed {
  1038.   return &postponed_sub
  1039.     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
  1040.   local *dbline = shift;
  1041.   my $filename = $dbline;
  1042.   $filename =~ s/^_<//;
  1043.   $signal = 1, print $OUT "'$filename' loaded...\n"
  1044.     if $break_on_load{$filename};
  1045.   print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
  1046.   return unless $postponed_file{$filename};
  1047.   $had_breakpoints{$filename}++;
  1048.   my $key;
  1049.   for $key (keys %{$postponed_file{$filename}}) {
  1050.     $dbline{$key} = $ {$postponed_file{$filename}}{$key};
  1051.   }
  1052.   delete $postponed_file{$filename};
  1053. }
  1054.  
  1055. sub dumpit {
  1056.     local ($savout) = select($OUT);
  1057.     my $osingle = $single;
  1058.     my $otrace = $trace;
  1059.     $single = $trace = 0;
  1060.     local $frame = 0;
  1061.     local $doret = -2;
  1062.     unless (defined &main::dumpValue) {
  1063.     do 'dumpvar.pl';
  1064.     }
  1065.     if (defined &main::dumpValue) {
  1066.     &main::dumpValue(shift);
  1067.     } else {
  1068.     print $OUT "dumpvar.pl not available.\n";
  1069.     }
  1070.     $single = $osingle;
  1071.     $trace = $otrace;
  1072.     select ($savout);    
  1073. }
  1074.  
  1075.  
  1076. sub print_trace {
  1077.   my $fh = shift;
  1078.   my @sub = dump_trace($_[0] + 1, $_[1]);
  1079.   my $short = $_[2];        # Print short report, next one for sub name
  1080.   my $s;
  1081.   for ($i=0; $i <= $#sub; $i++) {
  1082.     last if $signal;
  1083.     local $" = ', ';
  1084.     my $args = defined $sub[$i]{args} 
  1085.     ? "(@{ $sub[$i]{args} })"
  1086.       : '' ;
  1087.     $args = (substr $args, 0, $maxtrace - 3) . '...' 
  1088.       if length $args > $maxtrace;
  1089.     my $file = $sub[$i]{file};
  1090.     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
  1091.     $s = $sub[$i]{sub};
  1092.     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;    
  1093.     if ($short) {
  1094.       my $sub = @_ >= 4 ? $_[3] : $s;
  1095.       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
  1096.     } else {
  1097.       print $fh "$sub[$i]{context} = $s$args" .
  1098.     " called from $file" . 
  1099.       " line $sub[$i]{line}\n";
  1100.     }
  1101.   }
  1102. }
  1103.  
  1104. sub dump_trace {
  1105.   my $skip = shift;
  1106.   my $count = shift || 1e9;
  1107.   $skip++;
  1108.   $count += $skip;
  1109.   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
  1110.   my $nothard = not $frame & 8;
  1111.   local $frame = 0;        # Do not want to trace this.
  1112.   my $otrace = $trace;
  1113.   $trace = 0;
  1114.   for ($i = $skip; 
  1115.        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); 
  1116.        $i++) {
  1117.     @a = ();
  1118.     for $arg (@args) {
  1119.       my $type;
  1120.       if (not defined $arg) {
  1121.     push @a, "undef";
  1122.       } elsif ($nothard and tied $arg) {
  1123.     push @a, "tied";
  1124.       } elsif ($nothard and $type = ref $arg) {
  1125.     push @a, "ref($type)";
  1126.       } else {
  1127.     local $_ = "$arg";    # Safe to stringify now - should not call f().
  1128.     s/([\'\\])/\\$1/g;
  1129.     s/(.*)/'$1'/s
  1130.       unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
  1131.     s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  1132.     s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  1133.     push(@a, $_);
  1134.       }
  1135.     }
  1136.     $context = $context ? '@' : "\$";
  1137.     $args = $h ? [@a] : undef;
  1138.     $e =~ s/\n\s*\;\s*\Z// if $e;
  1139.     $e =~ s/([\\\'])/\\$1/g if $e;
  1140.     if ($r) {
  1141.       $sub = "require '$e'";
  1142.     } elsif (defined $r) {
  1143.       $sub = "eval '$e'";
  1144.     } elsif ($sub eq '(eval)') {
  1145.       $sub = "eval {...}";
  1146.     }
  1147.     push(@sub, {context => $context, sub => $sub, args => $args,
  1148.         file => $file, line => $line});
  1149.     last if $signal;
  1150.   }
  1151.   $trace = $otrace;
  1152.   @sub;
  1153. }
  1154.  
  1155. sub action {
  1156.     my $action = shift;
  1157.     while ($action =~ s/\\$//) {
  1158.     $action .= &gets;
  1159.     }
  1160.     $action;
  1161. }
  1162.  
  1163. sub gets {
  1164.     local($.);
  1165.     &readline("cont: ");
  1166. }
  1167.  
  1168. sub system {
  1169.     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
  1170.     open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
  1171.     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
  1172.     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
  1173.     system(@_);
  1174.     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
  1175.     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
  1176.     close(SAVEIN); close(SAVEOUT);
  1177.     &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
  1178.       ( $? & 128 ) ? " (core dumped)" : "",
  1179.       ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
  1180.     $?;
  1181. }
  1182.  
  1183. sub setterm {
  1184.     local $frame = 0;
  1185.     local $doret = -2;
  1186.     local @stack = @stack;        # Prevent growth by failing `use'.
  1187.     eval { require Term::ReadLine } or die $@;
  1188.     if ($notty) {
  1189.     if ($tty) {
  1190.         open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
  1191.         open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
  1192.         $IN = \*IN;
  1193.         $OUT = \*OUT;
  1194.         my $sel = select($OUT);
  1195.         $| = 1;
  1196.         select($sel);
  1197.     } else {
  1198.         eval "require Term::Rendezvous;" or die $@;
  1199.         my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
  1200.         my $term_rv = new Term::Rendezvous $rv;
  1201.         $IN = $term_rv->IN;
  1202.         $OUT = $term_rv->OUT;
  1203.     }
  1204.     }
  1205.     if (!$rl) {
  1206.     $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
  1207.     } else {
  1208.     $term = new Term::ReadLine 'perldb', $IN, $OUT;
  1209.  
  1210.     $rl_attribs = $term->Attribs;
  1211.     $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' 
  1212.       if defined $rl_attribs->{basic_word_break_characters} 
  1213.         and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
  1214.     $rl_attribs->{special_prefixes} = '$@&%';
  1215.     $rl_attribs->{completer_word_break_characters} .= '$@&%';
  1216.     $rl_attribs->{completion_function} = \&db_complete; 
  1217.     }
  1218.     $LINEINFO = $OUT unless defined $LINEINFO;
  1219.     $lineinfo = $console unless defined $lineinfo;
  1220.     $term->MinLine(2);
  1221.     if ($term->Features->{setHistory} and "@hist" ne "?") {
  1222.       $term->SetHistory(@hist);
  1223.     }
  1224.     ornaments($ornaments) if defined $ornaments;
  1225.     $term_pid = $$;
  1226. }
  1227.  
  1228. sub resetterm {            # We forked, so we need a different TTY
  1229.     $term_pid = $$;
  1230.     if (defined &get_fork_TTY) {
  1231.       &get_fork_TTY;
  1232.     } elsif (not defined $fork_TTY 
  1233.          and defined $ENV{TERM} and $ENV{TERM} eq 'xterm' 
  1234.          and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) { 
  1235.         open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
  1236.  sleep 10000000' |];
  1237.         $fork_TTY = <XT>;
  1238.         chomp $fork_TTY;
  1239.     }
  1240.     if (defined $fork_TTY) {
  1241.       TTY($fork_TTY);
  1242.       undef $fork_TTY;
  1243.     } else {
  1244.       print $OUT "Forked, but do not know how to change a TTY.\n",
  1245.           "Define \$DB::fork_TTY or get_fork_TTY().\n";
  1246.     }
  1247. }
  1248.  
  1249. sub readline {
  1250.   if (@typeahead) {
  1251.     my $left = @typeahead;
  1252.     my $got = shift @typeahead;
  1253.     print $OUT "auto(-$left)", shift, $got, "\n";
  1254.     $term->AddHistory($got) 
  1255.       if length($got) > 1 and defined $term->Features->{addHistory};
  1256.     return $got;
  1257.   }
  1258.   local $frame = 0;
  1259.   local $doret = -2;
  1260.   $term->readline(@_);
  1261. }
  1262.  
  1263. sub dump_option {
  1264.     my ($opt, $val)= @_;
  1265.     $val = option_val($opt,'N/A');
  1266.     $val =~ s/([\\\'])/\\$1/g;
  1267.     printf $OUT "%20s = '%s'\n", $opt, $val;
  1268. }
  1269.  
  1270. sub option_val {
  1271.     my ($opt, $default)= @_;
  1272.     my $val;
  1273.     if (defined $optionVars{$opt}
  1274.     and defined $ {$optionVars{$opt}}) {
  1275.     $val = $ {$optionVars{$opt}};
  1276.     } elsif (defined $optionAction{$opt}
  1277.     and defined &{$optionAction{$opt}}) {
  1278.     $val = &{$optionAction{$opt}}();
  1279.     } elsif (defined $optionAction{$opt}
  1280.          and not defined $option{$opt}
  1281.          or defined $optionVars{$opt}
  1282.          and not defined $ {$optionVars{$opt}}) {
  1283.     $val = $default;
  1284.     } else {
  1285.     $val = $option{$opt};
  1286.     }
  1287.     $val
  1288. }
  1289.  
  1290. sub parse_options {
  1291.     local($_)= @_;
  1292.     while ($_ ne "") {
  1293.     s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
  1294.     my ($opt,$sep) = ($1,$2);
  1295.     my $val;
  1296.     if ("?" eq $sep) {
  1297.         print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
  1298.           if /^\S/;
  1299.     } elsif ($sep !~ /\S/) {
  1300.         $val = "1";
  1301.     } elsif ($sep eq "=") {
  1302.         s/^(\S*)($|\s+)//;
  1303.         $val = $1;
  1304.     } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
  1305.         my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
  1306.         s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
  1307.           print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
  1308.         $val = $1;
  1309.         $val =~ s/\\([\\$end])/$1/g;
  1310.     }
  1311.     my ($option);
  1312.     my $matches =
  1313.       grep(  /^\Q$opt/ && ($option = $_),  @options  );
  1314.     $matches =  grep(  /^\Q$opt/i && ($option = $_),  @options  )
  1315.       unless $matches;
  1316.     print $OUT "Unknown option `$opt'\n" unless $matches;
  1317.     print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
  1318.     $option{$option} = $val if $matches == 1 and defined $val;
  1319.     eval "local \$frame = 0; local \$doret = -2; 
  1320.           require '$optionRequire{$option}'"
  1321.       if $matches == 1 and defined $optionRequire{$option} and defined $val;
  1322.     $ {$optionVars{$option}} = $val 
  1323.       if $matches == 1
  1324.         and defined $optionVars{$option} and defined $val;
  1325.     & {$optionAction{$option}} ($val) 
  1326.       if $matches == 1
  1327.         and defined $optionAction{$option}
  1328.           and defined &{$optionAction{$option}} and defined $val;
  1329.     &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
  1330.         s/^\s+//;
  1331.     }
  1332. }
  1333.  
  1334. sub set_list {
  1335.   my ($stem,@list) = @_;
  1336.   my $val;
  1337.   $ENV{"$ {stem}_n"} = @list;
  1338.   for $i (0 .. $#list) {
  1339.     $val = $list[$i];
  1340.     $val =~ s/\\/\\\\/g;
  1341.     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
  1342.     $ENV{"$ {stem}_$i"} = $val;
  1343.   }
  1344. }
  1345.  
  1346. sub get_list {
  1347.   my $stem = shift;
  1348.   my @list;
  1349.   my $n = delete $ENV{"$ {stem}_n"};
  1350.   my $val;
  1351.   for $i (0 .. $n - 1) {
  1352.     $val = delete $ENV{"$ {stem}_$i"};
  1353.     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
  1354.     push @list, $val;
  1355.   }
  1356.   @list;
  1357. }
  1358.  
  1359. sub catch {
  1360.     $signal = 1;
  1361.     return;            # Put nothing on the stack - malloc/free land!
  1362. }
  1363.  
  1364. sub warn {
  1365.     my($msg)= join("",@_);
  1366.     $msg .= ": $!\n" unless $msg =~ /\n$/;
  1367.     print $OUT $msg;
  1368. }
  1369.  
  1370. sub TTY {
  1371.     if (@_ and $term and $term->Features->{newTTY}) {
  1372.       my ($in, $out) = shift;
  1373.       if ($in =~ /,/) {
  1374.     ($in, $out) = split /,/, $in, 2;
  1375.       } else {
  1376.     $out = $in;
  1377.       }
  1378.       open IN, $in or die "cannot open `$in' for read: $!";
  1379.       open OUT, ">$out" or die "cannot open `$out' for write: $!";
  1380.       $term->newTTY(\*IN, \*OUT);
  1381.       $IN    = \*IN;
  1382.       $OUT    = \*OUT;
  1383.       return $tty = $in;
  1384.     } elsif ($term and @_) {
  1385.     &warn("Too late to set TTY, enabled on next `R'!\n");
  1386.     } 
  1387.     $tty = shift if @_;
  1388.     $tty or $console;
  1389. }
  1390.  
  1391. sub noTTY {
  1392.     if ($term) {
  1393.     &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
  1394.     }
  1395.     $notty = shift if @_;
  1396.     $notty;
  1397. }
  1398.  
  1399. sub ReadLine {
  1400.     if ($term) {
  1401.     &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
  1402.     }
  1403.     $rl = shift if @_;
  1404.     $rl;
  1405. }
  1406.  
  1407. sub tkRunning {
  1408.     if ($ {$term->Features}{tkRunning}) {
  1409.         return $term->tkRunning(@_);
  1410.     } else {
  1411.     print $OUT "tkRunning not supported by current ReadLine package.\n";
  1412.     0;
  1413.     }
  1414. }
  1415.  
  1416. sub NonStop {
  1417.     if ($term) {
  1418.     &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
  1419.     }
  1420.     $runnonstop = shift if @_;
  1421.     $runnonstop;
  1422. }
  1423.  
  1424. sub pager {
  1425.     if (@_) {
  1426.     $pager = shift;
  1427.     $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
  1428.     }
  1429.     $pager;
  1430. }
  1431.  
  1432. sub shellBang {
  1433.     if (@_) {
  1434.     $sh = quotemeta shift;
  1435.     $sh .= "\\b" if $sh =~ /\w$/;
  1436.     }
  1437.     $psh = $sh;
  1438.     $psh =~ s/\\b$//;
  1439.     $psh =~ s/\\(.)/$1/g;
  1440.     &sethelp;
  1441.     $psh;
  1442. }
  1443.  
  1444. sub ornaments {
  1445.   if (defined $term) {
  1446.     local ($warnLevel,$dieLevel) = (0, 1);
  1447.     return '' unless $term->Features->{ornaments};
  1448.     eval { $term->ornaments(@_) } || '';
  1449.   } else {
  1450.     $ornaments = shift;
  1451.   }
  1452. }
  1453.  
  1454. sub recallCommand {
  1455.     if (@_) {
  1456.     $rc = quotemeta shift;
  1457.     $rc .= "\\b" if $rc =~ /\w$/;
  1458.     }
  1459.     $prc = $rc;
  1460.     $prc =~ s/\\b$//;
  1461.     $prc =~ s/\\(.)/$1/g;
  1462.     &sethelp;
  1463.     $prc;
  1464. }
  1465.  
  1466. sub LineInfo {
  1467.     return $lineinfo unless @_;
  1468.     $lineinfo = shift;
  1469.     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
  1470.     $emacs = ($stream =~ /^\|/);
  1471.     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
  1472.     $LINEINFO = \*LINEINFO;
  1473.     my $save = select($LINEINFO);
  1474.     $| = 1;
  1475.     select($save);
  1476.     $lineinfo;
  1477. }
  1478.  
  1479. sub list_versions {
  1480.   my %version;
  1481.   my $file;
  1482.   for (keys %INC) {
  1483.     $file = $_;
  1484.     s,\.p[lm]$,,i ;
  1485.     s,/,::,g ;
  1486.     s/^perl5db$/DB/;
  1487.     s/^Term::ReadLine::readline$/readline/;
  1488.     if (defined $ { $_ . '::VERSION' }) {
  1489.       $version{$file} = "$ { $_ . '::VERSION' } from ";
  1490.     } 
  1491.     $version{$file} .= $INC{$file};
  1492.   }
  1493.   do 'dumpvar.pl' unless defined &main::dumpValue;
  1494.   if (defined &main::dumpValue) {
  1495.     local $frame = 0;
  1496.     &main::dumpValue(\%version);
  1497.   } else {
  1498.     print $OUT "dumpvar.pl not available.\n";
  1499.   }
  1500. }
  1501.  
  1502. sub sethelp {
  1503.     $help = "
  1504. T        Stack trace.
  1505. s [expr]    Single step [in expr].
  1506. n [expr]    Next, steps over subroutine calls [in expr].
  1507. <CR>        Repeat last n or s command.
  1508. r        Return from current subroutine.
  1509. c [line|sub]    Continue; optionally inserts a one-time-only breakpoint
  1510.         at the specified position.
  1511. l min+incr    List incr+1 lines starting at min.
  1512. l min-max    List lines min through max.
  1513. l line        List single line.
  1514. l subname    List first window of lines from subroutine.
  1515. l        List next window of lines.
  1516. -        List previous window of lines.
  1517. w [line]    List window around line.
  1518. .        Return to the executed line.
  1519. f filename    Switch to viewing filename. Must be loaded.
  1520. /pattern/    Search forwards for pattern; final / is optional.
  1521. ?pattern?    Search backwards for pattern; final ? is optional.
  1522. L        List all breakpoints and actions.
  1523. S [[!]pattern]    List subroutine names [not] matching pattern.
  1524. t        Toggle trace mode.
  1525. t expr        Trace through execution of expr.
  1526. b [line] [condition]
  1527.         Set breakpoint; line defaults to the current execution line;
  1528.         condition breaks if it evaluates to true, defaults to '1'.
  1529. b subname [condition]
  1530.         Set breakpoint at first line of subroutine.
  1531. b load filename Set breakpoint on `require'ing the given file.
  1532. b postpone subname [condition]
  1533.         Set breakpoint at first line of subroutine after 
  1534.         it is compiled.
  1535. b compile subname
  1536.         Stop after the subroutine is compiled.
  1537. d [line]    Delete the breakpoint for line.
  1538. D        Delete all breakpoints.
  1539. a [line] command
  1540.         Set an action to be done before the line is executed.
  1541.         Sequence is: check for breakpoint, print line if necessary,
  1542.         do action, prompt user if breakpoint or step, evaluate line.
  1543. A        Delete all actions.
  1544. V [pkg [vars]]    List some (default all) variables in package (default current).
  1545.         Use ~pattern and !pattern for positive and negative regexps.
  1546. X [vars]    Same as \"V currentpackage [vars]\".
  1547. x expr        Evals expression in array context, dumps the result.
  1548. m expr        Evals expression in array context, prints methods callable
  1549.         on the first element of the result.
  1550. m class        Prints methods callable via the given class.
  1551. O [opt[=val]] [opt\"val\"] [opt?]...
  1552.         Set or query values of options.  val defaults to 1.  opt can
  1553.         be abbreviated.  Several options can be listed.
  1554.     recallCommand, ShellBang:    chars used to recall command or spawn shell;
  1555.     pager:            program for output of \"|cmd\";
  1556.     tkRunning:            run Tk while prompting (with ReadLine);
  1557.     signalLevel warnLevel dieLevel:    level of verbosity;
  1558.     inhibit_exit        Allows stepping off the end of the script.
  1559.   The following options affect what happens with V, X, and x commands:
  1560.     arrayDepth, hashDepth:    print only first N elements ('' for all);
  1561.     compactDump, veryCompact:    change style of array and hash dump;
  1562.     globPrint:            whether to print contents of globs;
  1563.     DumpDBFiles:        dump arrays holding debugged files;
  1564.     DumpPackages:        dump symbol tables of packages;
  1565.     quote, HighBit, undefPrint:    change style of string dump;
  1566.   Option PrintRet affects printing of return value after r command,
  1567.          frame    affects printing messages on entry and exit from subroutines.
  1568.          AutoTrace affects printing messages on every possible breaking point.
  1569.      maxTraceLen gives maximal length of evals/args listed in stack trace.
  1570.      ornaments affects screen appearance of the command line.
  1571.         During startup options are initialized from \$ENV{PERLDB_OPTS}.
  1572.         You can put additional initialization options TTY, noTTY,
  1573.         ReadLine, and NonStop there (or use `R' after you set them).
  1574. < command    Define Perl command to run before each prompt.
  1575. << command    Add to the list of Perl commands to run before each prompt.
  1576. > command    Define Perl command to run after each prompt.
  1577. >> command    Add to the list of Perl commands to run after each prompt.
  1578. \{ commandline    Define debugger command to run before each prompt.
  1579. \{{ commandline    Add to the list of debugger commands to run before each prompt.
  1580. $prc number    Redo a previous command (default previous command).
  1581. $prc -number    Redo number'th-to-last command.
  1582. $prc pattern    Redo last command that started with pattern.
  1583.         See 'O recallCommand' too.
  1584. $psh$psh cmd      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
  1585.   . ( $rc eq $sh ? "" : "
  1586. $psh [cmd]     Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
  1587.         See 'O shellBang' too.
  1588. H -number    Display last number commands (default all).
  1589. p expr        Same as \"print {DB::OUT} expr\" in current package.
  1590. |dbcmd        Run debugger command, piping DB::OUT to current pager.
  1591. ||dbcmd        Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
  1592. \= [alias value]    Define a command alias, or list current aliases.
  1593. command        Execute as a perl statement in current package.
  1594. v        Show versions of loaded modules.
  1595. R        Pure-man-restart of debugger, some of debugger state
  1596.         and command-line options may be lost.
  1597.         Currently the following setting are preserved: 
  1598.         history, breakpoints and actions, debugger Options 
  1599.         and the following command-line options: -w, -I, -e.
  1600. h [db_command]    Get help [on a specific debugger command], enter |h to page.
  1601. h h        Summary of debugger commands.
  1602. q or ^D        Quit. Set \$DB::finished to 0 to debug global destruction.
  1603.  
  1604. ";
  1605.     $summary = <<"END_SUM";
  1606. List/search source lines:               Control script execution:
  1607.   l [ln|sub]  List source code            T           Stack trace
  1608.   - or .      List previous/current line  s [expr]    Single step [in expr]
  1609.   w [line]    List around line            n [expr]    Next, steps over subs
  1610.   f filename  View source in file         <CR>        Repeat last n or s
  1611.   /pattern/ ?patt?   Search forw/backw    r           Return from subroutine
  1612.   v          Show versions of modules    c [ln|sub]  Continue until position
  1613. Debugger controls:                        L           List break pts & actions
  1614.   O [...]     Set debugger options        t [expr]    Toggle trace [trace expr]
  1615.   <[<] or {[{] [cmd]   Do before prompt   b [ln/event] [c]     Set breakpoint
  1616.   >[>] [cmd]  Do after prompt             b sub [c]   Set breakpoint for sub
  1617.   $prc [N|pat]   Redo a previous command     d [line]    Delete a breakpoint
  1618.   H [-num]    Display last num commands   D           Delete all breakpoints
  1619.   = [a val]   Define/list an alias        a [ln] cmd  Do cmd before line
  1620.   h [db_cmd]  Get help on command         A           Delete all actions
  1621.   |[|]dbcmd   Send output to pager        $psh\[$psh\] syscmd Run cmd in a subprocess
  1622.   q or ^D     Quit              R          Attempt a restart
  1623. Data Examination:          expr     Execute perl code, also see: s,n,t expr
  1624.   x|m expr    Evals expr in array context, dumps the result or lists methods.
  1625.   p expr    Print expression (uses script's current package).
  1626.   S [[!]pat]    List subroutine names [not] matching pattern
  1627.   V [Pk [Vars]]    List Variables in Package.  Vars can be ~pattern or !pattern.
  1628.   X [Vars]    Same as \"V current_package [Vars]\".
  1629. END_SUM
  1630. }
  1631.  
  1632. sub diesignal {
  1633.     local $frame = 0;
  1634.     local $doret = -2;
  1635.     $SIG{'ABRT'} = 'DEFAULT';
  1636.     kill 'ABRT', $$ if $panic++;
  1637.     if (defined &Carp::longmess) {
  1638.     local $SIG{__WARN__} = '';
  1639.     local $Carp::CarpLevel = 2;        # mydie + confess
  1640.     &warn(Carp::longmess("Signal @_"));
  1641.     }
  1642.     else {
  1643.     print $DB::OUT "Got signal @_\n";
  1644.     }
  1645.     kill 'ABRT', $$;
  1646. }
  1647.  
  1648. sub dbwarn { 
  1649.   local $frame = 0;
  1650.   local $doret = -2;
  1651.   local $SIG{__WARN__} = '';
  1652.   local $SIG{__DIE__} = '';
  1653.   eval { require Carp };    # If error/warning during compilation,
  1654.   warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
  1655.     unless defined &Carp::longmess;
  1656.   my ($mysingle,$mytrace) = ($single,$trace);
  1657.   $single = 0; $trace = 0;
  1658.   my $mess = Carp::longmess(@_);
  1659.   ($single,$trace) = ($mysingle,$mytrace);
  1660.   &warn($mess); 
  1661. }
  1662.  
  1663. sub dbdie {
  1664.   local $frame = 0;
  1665.   local $doret = -2;
  1666.   local $SIG{__DIE__} = '';
  1667.   local $SIG{__WARN__} = '';
  1668.   my $i = 0; my $ineval = 0; my $sub;
  1669.   if ($dieLevel != 2) {
  1670.     while ((undef,undef,undef,$sub) = caller(++$i)) {
  1671.       $ineval = 1, last if $sub eq '(eval)';
  1672.     }
  1673.     {
  1674.       local $SIG{__WARN__} = \&dbwarn;
  1675.       &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
  1676.     }
  1677.     die @_ if $ineval and $dieLevel < 2;
  1678.   }
  1679.   eval { require Carp };    # If error/warning during compilation,
  1680.   die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
  1681.   my ($mysingle,$mytrace) = ($single,$trace);
  1682.   $single = 0; $trace = 0;
  1683.   my $mess = Carp::longmess(@_);
  1684.   ($single,$trace) = ($mysingle,$mytrace);
  1685.   die $mess;
  1686. }
  1687.  
  1688. sub warnLevel {
  1689.   if (@_) {
  1690.     $prevwarn = $SIG{__WARN__} unless $warnLevel;
  1691.     $warnLevel = shift;
  1692.     if ($warnLevel) {
  1693.       $SIG{__WARN__} = \&DB::dbwarn;
  1694.     } else {
  1695.       $SIG{__WARN__} = $prevwarn;
  1696.     }
  1697.   }
  1698.   $warnLevel;
  1699. }
  1700.  
  1701. sub dieLevel {
  1702.   if (@_) {
  1703.     $prevdie = $SIG{__DIE__} unless $dieLevel;
  1704.     $dieLevel = shift;
  1705.     if ($dieLevel) {
  1706.       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
  1707.       print $OUT "Stack dump during die enabled", 
  1708.         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
  1709.       if $I_m_init;
  1710.       print $OUT "Dump printed too.\n" if $dieLevel > 2;
  1711.     } else {
  1712.       $SIG{__DIE__} = $prevdie;
  1713.       print $OUT "Default die handler restored.\n";
  1714.     }
  1715.   }
  1716.   $dieLevel;
  1717. }
  1718.  
  1719. sub signalLevel {
  1720.   if (@_) {
  1721.     $prevsegv = $SIG{SEGV} unless $signalLevel;
  1722.     $prevbus = $SIG{BUS} unless $signalLevel;
  1723.     $signalLevel = shift;
  1724.     if ($signalLevel) {
  1725.       $SIG{SEGV} = \&DB::diesignal;
  1726.       $SIG{BUS} = \&DB::diesignal;
  1727.     } else {
  1728.       $SIG{SEGV} = $prevsegv;
  1729.       $SIG{BUS} = $prevbus;
  1730.     }
  1731.   }
  1732.   $signalLevel;
  1733. }
  1734.  
  1735. sub find_sub {
  1736.   my $subr = shift;
  1737.   return unless defined &$subr;
  1738.   $sub{$subr} or do {
  1739.     $subr = \&$subr;        # Hard reference
  1740.     my $s;
  1741.     for (keys %sub) {
  1742.       $s = $_, last if $subr eq \&$_;
  1743.     }
  1744.     $sub{$s} if $s;
  1745.   }
  1746. }
  1747.  
  1748. sub methods {
  1749.   my $class = shift;
  1750.   $class = ref $class if ref $class;
  1751.   local %seen;
  1752.   local %packs;
  1753.   methods_via($class, '', 1);
  1754.   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
  1755. }
  1756.  
  1757. sub methods_via {
  1758.   my $class = shift;
  1759.   return if $packs{$class}++;
  1760.   my $prefix = shift;
  1761.   my $prepend = $prefix ? "via $prefix: " : '';
  1762.   my $name;
  1763.   for $name (grep {defined &{$ {"$ {class}::"}{$_}}} 
  1764.          sort keys %{"$ {class}::"}) {
  1765.     next if $seen{ $name }++;
  1766.     print $DB::OUT "$prepend$name\n";
  1767.   }
  1768.   return unless shift;        # Recurse?
  1769.   for $name (@{"$ {class}::ISA"}) {
  1770.     $prepend = $prefix ? $prefix . " -> $name" : $name;
  1771.     methods_via($name, $prepend, 1);
  1772.   }
  1773. }
  1774.  
  1775.  
  1776. BEGIN {            # This does not compile, alas.
  1777.   $IN = \*STDIN;        # For bugs before DB::OUT has been opened
  1778.   $OUT = \*STDERR;        # For errors before DB::OUT has been opened
  1779.   $sh = '!';
  1780.   $rc = ',';
  1781.   @hist = ('?');
  1782.   $deep = 100;            # warning if stack gets this deep
  1783.   $window = 10;
  1784.   $preview = 3;
  1785.   $sub = '';
  1786.   $SIG{INT} = \&DB::catch;
  1787.  
  1788.   $db_stop = 0;            # Compiler warning
  1789.   $db_stop = 1 << 30;
  1790.   $level = 0;            # Level of recursive debugging
  1791.   @postponed = @stack = (0);
  1792.   $doret = -2;
  1793.   $frame = 0;
  1794. }
  1795.  
  1796. BEGIN {$^W = $ini_warn;}    # Switch warnings back
  1797.  
  1798.  
  1799. sub db_complete {
  1800.   my($text, $line, $start) = @_;
  1801.   my ($itext, $search, $prefix, $pack) =
  1802.     ($text, "^\Q$ {'package'}::\E([^:]+)\$");
  1803.   
  1804.   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
  1805.                                (map { /$search/ ? ($1) : () } keys %sub)
  1806.     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
  1807.   return sort grep /^\Q$text/, values %INC # files
  1808.     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
  1809.   return sort map {($_, db_complete($_ . "::", "V ", 2))}
  1810.     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
  1811.       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
  1812.   return sort map {($_, db_complete($_ . "::", "V ", 2))}
  1813.     grep !/^main::/,
  1814.       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
  1815.     if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ 
  1816.       and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
  1817.   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
  1818.     $prefix = length($1) - length($text);
  1819.     $text = $1;
  1820.     return sort 
  1821.     map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
  1822.   }
  1823.   if ((substr $text, 0, 1) eq '&') { # subroutines
  1824.     $text = substr $text, 1;
  1825.     $prefix = "&";
  1826.     return sort map "$prefix$_", 
  1827.                grep /^\Q$text/, 
  1828.                  (keys %sub),
  1829.                  (map { /$search/ ? ($1) : () } 
  1830.             keys %sub);
  1831.   }
  1832.   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
  1833.     $pack = ($1 eq 'main' ? '' : $1) . '::';
  1834.     $prefix = (substr $text, 0, 1) . $1 . '::';
  1835.     $text = $2;
  1836.     my @out 
  1837.       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
  1838.     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
  1839.       return db_complete($out[0], $line, $start);
  1840.     }
  1841.     return sort @out;
  1842.   }
  1843.   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
  1844.     $pack = ($package eq 'main' ? '' : $package) . '::';
  1845.     $prefix = substr $text, 0, 1;
  1846.     $text = substr $text, 1;
  1847.     my @out = map "$prefix$_", grep /^\Q$text/, 
  1848.        (grep /^_?[a-zA-Z]/, keys %$pack), 
  1849.        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
  1850.     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
  1851.       return db_complete($out[0], $line, $start);
  1852.     }
  1853.     return sort @out;
  1854.   }
  1855.   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
  1856.     my @out = grep /^\Q$text/, @options;
  1857.     my $val = option_val($out[0], undef);
  1858.     my $out = '? ';
  1859.     if (not defined $val or $val =~ /[\n\r]/) {
  1860.     } elsif ($val =~ /\s/) {
  1861.       my $found;
  1862.       foreach $l (split //, qq/\"\'\#\|/) {
  1863.     $out = "$l$val$l ", last if (index $val, $l) == -1;
  1864.       }
  1865.     } else {
  1866.       $out = "=$val ";
  1867.     }
  1868.     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
  1869.     return sort @out;
  1870.   }
  1871.   return $term->filename_list($text); # filenames
  1872. }
  1873.  
  1874. sub end_report {
  1875.   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
  1876. }
  1877.  
  1878. END {
  1879.   $finished = $inhibit_exit;    # So that some keys may be disabled.
  1880.   $DB::single = !$exiting && !$runnonstop;
  1881.   DB::fake::at_exit() unless $exiting or $runnonstop;
  1882. }
  1883.  
  1884. package DB::fake;
  1885.  
  1886. sub at_exit {
  1887.   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
  1888. }
  1889.  
  1890. package DB;            # Do not trace this 1; below!
  1891.  
  1892. 1;
  1893.